Hardcore Visual Basic 5.0 (2nd Edition)/Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso/Code/SLISTBOX.CLS

Text File | 1997-06-14 | 16KB | 614 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CSortedListBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'$ Uses SLISTBOX.BAS UTILITY.BAS

Public Enum ESortError
    eseNone = 0
    eseItemNotFound = 1
    eseOutOfRange = 2
    eseDuplicateNotAllowed = 3
    eseNoSelection = 4
    eseNotListBox = 5
    eseAlreadySorted = 6
    eseUnknown = 7
End Enum

Private lst As Control
Private esmMode As ESortMode
Private fHiToLo As Boolean

Private asError(0 To 7) As String

Public LastError As Integer

''' Public Methods Unique to This Class '''

' Create sorted list box from unsorted list box or similar control
Function Create(lstA As Control, Optional fHiToLoA As Boolean = False, _
                Optional esmModeA As ESortMode = esmUnsorted) As Boolean

    ' Must have ListCount, List, ListIndex, AddItem, and RemoveItem
    On Error GoTo CreateFail
    Dim v As Variant
    LastError = eseNotListBox
    v = lstA.ListCount
    lstA.AddItem v, 0
    v = lstA.list(0)
    lstA.list(0) = v
    v = lstA.ListIndex
    lstA.RemoveItem 0
    ' Make sure list isn't already sorted
    LastError = eseAlreadySorted
    If lstA.Sorted Then GoTo CreateFail

    ' Initialize internal data
    LastError = eseUnknown
    fHiToLo = fHiToLoA
    esmMode = esmSortVal
    If esmModeA <> -1 Then esmMode = esmModeA
    Set lst = lstA
    ' Sort it
    Sort 0, lst.ListCount - 1
    Create = True
    LastError = eseNone
    Exit Function

CreateFail:
    Create = False
End Function

' Note that our AddItem only takes an item. You cannot specify the
' insert position with a sorted list as you can with an unsorted list.
' Also, you cannot insert an item that already exists into a sorted
' list. A request to do so will be ignored.
Sub AddItem(sItem As String)
    LastError = eseNone
    ' Binary search for the item
    Dim iPos As Integer
    If BSearch(sItem, iPos) Then
        LastError = eseDuplicateNotAllowed
    Else
        lst.AddItem sItem, iPos
    End If
End Sub

' RemoveItem takes numeric 0-based item index
Sub RemoveItem(iItem As Integer)
    lst.RemoveItem iItem
End Sub

' Collection Methods
' Same as AddItem but with collection name (but not extra arguments)
Sub Add(vItem As Variant)
    LastError = eseNone
    ' Binary search for the item
    Dim iPos As Integer
    If BSearch(vItem, iPos) Then
        LastError = eseDuplicateNotAllowed
    Else
        lst.AddItem vItem, iPos - 1
    End If
End Sub

' Same as RemoveItem but has collection name and is 1-based
Sub Remove(vItem As Variant)
    LastError = eseNone
    If IsNumeric(vItem) Then
        If vItem > Count Or vItem < 1 Then LastError = eseOutOfRange: Exit Sub
    Else
        vItem = Match(vItem)
        If vItem = 0 Then LastError = eseItemNotFound: Exit Sub
    End If
    lst.RemoveItem vItem - 1
End Sub

' Similar to List property
Property Get Item(vIndex As Variant) As Variant
    LastError = eseNone
    If IsNumeric(vIndex) Then
        ' For numeric index, return string value
        Item = lst.list(vIndex - 1)
    Else
        ' For string index, return matching index or 0 for none
        Item = Match(vIndex)
        If Item = 0 Then LastError = eseItemNotFound
    End If
End Property

Property Let Item(vIndex As Variant, vItemA As Variant)
    LastError = eseNone
    ' For string index, look up matching index
    If Not IsNumeric(vIndex) Then
        vIndex = Match(vIndex)
        ' Quit if old item isn't found or if new item is found
        If vIndex = 0 Then
            LastError = eseItemNotFound
            Exit Property
        End If
        If Match(vItemA) Then
            LastError = eseDuplicateNotAllowed
            Exit Property
        End If
    End If
    ' Assign value by removing old and inserting new
    Remove vIndex
    Add vItemA
End Property

''' Public Properties Unique to This Class '''

Property Let HiToLo(fHiToLoA As Boolean)
    fHiToLo = fHiToLoA
    Sort 0, lst.ListCount - 1
End Property

Property Get HiToLo() As Boolean
    HiToLo = fHiToLo
End Property

Property Let SortMode(esmModeA As ESortMode)
    esmMode = esmModeA
    Sort 0, lst.ListCount - 1
End Property

Property Get SortMode() As ESortMode
    SortMode = esmMode
End Property

' Gives away the store for iteration
Property Get Items() As Collection
    Set Items = lst
End Property

' Collection name
Property Get Count() As Integer
    Count = lst.ListCount
End Property

' Index replaces Index property of a control array--if you really need
' to manage control-array at run-time, use Index of external list box
Property Get Index() As Variant
    LastError = eseNone
    Index = lst.ListIndex + 1
End Property

Property Let Index(vIndexA As Variant)
    LastError = eseNone
    If IsNumeric(vIndexA) Then
        lst.ListIndex = vIndexA - 1
    Else
        lst.ListIndex = Match(vIndexA) - 1
    End If
    If lst.ListIndex = -1 Then LastError = eseItemNotFound
End Property

Property Get IndexItem() As Variant
    LastError = eseNone
    IndexItem = lst.list(lst.ListIndex)
End Property

' 1-based versions of ItemData
Property Get Data(i As Integer) As Variant
    Data = lst.ItemData(i - 1)
End Property

Property Let Data(i As Integer, vDataA As Variant)
    lst.Data(i - 1) = vDataA
End Property

Property Get LastErrorStr() As String
    LastErrorStr = asError(LastError)
End Property


''' Public Methods From Contained Class '''

Sub Clear()
    lst.Clear
End Sub

Sub Drag(Optional vAction As Variant)
    If IsMissing(vAction) Then
        lst.Drag
    Else
        lst.Drag vAction
    End If
End Sub

Sub Move(x As Variant, Optional y As Variant, Optional dx As Variant, Optional dy As Variant)
    If IsMissing(y) Then
        lst.Move x
    ElseIf IsMissing(dx) Then
        lst.Move x, y
    ElseIf IsMissing(dy) Then
        lst.Move x, y, dx
    Else
        lst.Move x, y, dx, dy
    End If
End Sub

Sub Refresh()
    Sort 0, lst.ListCount - 1
    lst.Refresh
End Sub

Sub SetFocus()
    lst.SetFocus
End Sub

Sub ZOrder(Optional vPosition As Variant)
    If IsMissing(vPosition) Then
        lst.ZOrder
    Else
        lst.ZOrder vPosition
    End If
End Sub

''' Public Properties From Contained Class '''

Property Get BackColor() As Long
    BackColor = lst.BackColor
End Property

Property Let BackColor(iBackColorA As Long)
    lst.BackColor = iBackColorA
End Property

Property Get Columns() As Integer
    Columns = lst.Columns
End Property

Property Let Columns(iColumnsA As Integer)
    lst.Columns = iColumnsA
End Property

Property Get Enabled() As Boolean
    Enabled = lst.Enabled
End Property

Property Let Enabled(fEnabledA As Boolean)
    lst.Enabled = fEnabledA
End Property

Property Get ForeColor() As Long
    ForeColor = lst.ForeColor
End Property

Property Let ForeColor(iForeColorA As Long)
    lst.ForeColor = iForeColorA
End Property

Property Get Height() As Single
    Height = lst.Height
End Property

Property Let Height(rHeightA As Single)
    lst.Height = rHeightA
End Property

Property Get HelpContextID() As Integer
    HelpContextID = lst.HelpContextID
End Property

Property Let HelpContextID(iHelpContextIDA As Integer)
    lst.HelpContextID = iHelpContextIDA
End Property

Property Get hWnd() As Integer
    hWnd = lst.hWnd
End Property

Property Let hWnd(hWndA As Integer)
    lst.hWnd = hWndA
End Property

Property Get ItemData(i As Integer) As Variant
    ItemData = lst.ItemData(i)
End Property

Property Let ItemData(i As Integer, vItemDataA As Variant)
    lst.ItemData(i) = vItemDataA
End Property

Property Get Left() As Single
    Left = lst.Left
End Property

Property Let Left(rLeftA As Single)
    lst.Left = rLeftA
End Property

Property Get list(iIndex As Integer) As String
    list = lst.list(iIndex)
End Property

Property Let list(iIndex As Integer, sListA As String)
    lst.list(iIndex) = sListA
End Property

Property Get ListCount() As Integer
    ListCount = lst.ListCount
End Property

Property Get ListIndex() As Integer
    ListIndex = lst.ListIndex
End Property

Property Let ListIndex(iListIndexA As Integer)
    lst.ListIndex = iListIndexA
End Property

Property Get MousePointer() As Integer
    MousePointer = lst.MousePointer
End Property

Property Let MousePointer(iMousePointerA As Integer)
    lst.MousePointer = iMousePointerA
End Property

Property Get MultiSelect() As Integer
    MultiSelect = lst.MultiSelect
End Property

Property Let MultiSelect(iMultiSelectA As Integer)
    lst.MultiSelect = iMultiSelectA
End Property

Property Get NewIndex() As Integer
    NewIndex = lst.NewIndex
End Property

Property Get Parent() As Form
    Set Parent = lst.Parent
End Property

Property Get Selected(i As Integer) As Boolean
    Selected = lst.Selected(i)
End Property

Property Let Selected(i As Integer, fSelectedA As Boolean)
    lst.Selected(i) = fSelectedA
End Property

Property Get TabIndex() As Integer
    TabIndex = lst.TabIndex
End Property

Property Let TabIndex(iTabIndexA As Integer)
    lst.TabIndex = iTabIndexA
End Property

Property Get TabStop() As Boolean
    TabStop = lst.TabStop
End Property

Property Let TabStop(fTabStopA As Boolean)
    lst.TabStop = fTabStopA
End Property

Property Get Tag() As String
    Tag = lst.Tag
End Property

Property Let Tag(sTagA As String)
    lst.Tag = sTagA
End Property

Property Get Text() As String
    Text = lst.Text
End Property

Property Let Text(sTextA As String)
    lst.Text = sTextA
End Property

Property Get Top() As Single
    Top = lst.Top
End Property

Property Let Top(rTopA As Single)
    lst.Top = rTopA
End Property

Property Get TopIndex() As Integer
    TopIndex = lst.TopIndex
End Property

Property Let TopIndex(iTopIndexA As Integer)
    lst.TopIndex = iTopIndexA
End Property

Property Get Visible() As Boolean
    Visible = lst.Visible
End Property

Property Let Visible(fVisibleA As Boolean)
    lst.Visible = fVisibleA
End Property

Property Get Width() As Single
    Width = lst.Width
End Property

Property Let Width(rWidthA As Single)
    lst.Width = rWidthA
End Property

''' Private Procedures Used by Class '''

Private Function Match(ByVal sItem As String) As Long
    Dim iPos As Integer
    If BSearch(sItem, iPos) Then Match = iPos + 1 Else Match = 0
End Function

Private Sub Sort(iFirst As Integer, iLast As Integer)
    Dim vSplit As Variant
    Static fRand As Integer
    If fRand = False Then
        Randomize
        fRand = True
    End If

    If iFirst < iLast Then

        ' Only two elements in this subdivision. Exchange if
        ' they are out of order, and end recursive calls.
        If iLast - iFirst = 1 Then
            If Compare(lst.list(iFirst), lst.list(iLast)) > 0 Then
                Swap iFirst, iLast
            End If
        Else

            Dim i As Integer, j As Integer, iRand As Integer

            ' Pick pivot element at random and move to end
            ' (consider calling Randomize before sorting)
            iRand = GetRandom(iFirst, iLast)
            Swap iLast, iRand
            vSplit = lst.list(iLast)
            Do

                ' Move in from both sides towards the pivot element
                i = iFirst: j = iLast
                Do While (i < j) And _
                    Compare(lst.list(i), vSplit) <= 0
                    i = i + 1
                Loop
                Do While (j > i) And _
                    Compare(lst.list(j), vSplit) >= 0
                    j = j - 1
                Loop

                ' If we haven't reached the pivot element, it means
                ' that two elements on either side are out of order,
                ' so swap them
                If i < j Then
                    Swap i, j
                End If
            Loop While i < j

            ' Move the pivot element back to its proper place
            Swap i, iLast

            ' Recursively call Sort (pass the smaller
            ' subdivision first to use less stack space)
            If (i - iFirst) < (iLast - i) Then
                Sort iFirst, i - 1
                Sort i + 1, iLast
            Else
                Sort i + 1, iLast
                Sort iFirst, i - 1
            End If
        End If
    End If

End Sub

Private Function BSearch(vKey As Variant, iPos As Integer) As Boolean
    Dim iLo As Integer, iHi As Integer, iComp As Integer, iMid As Integer
    iLo = 0: iHi = lst.ListCount - 1
    Do
        iMid = iLo + ((iHi - iLo) \ 2)
        iComp = Compare(lst.list(iMid), vKey)
        Select Case iComp
        Case 0
            ' Item found
            iPos = iMid
            BSearch = True
            Exit Function
        Case Is > 0
            ' Item is in upper half
            iHi = iMid
            If iLo = iHi Then Exit Do
        Case Is < 0
            ' Item is in lower half
            iLo = iMid + 1
            If iLo > iHi Then Exit Do
        End Select
    Loop
    ' Item not found, but return position to insert
    iPos = iMid - (iComp < 0)
    BSearch = False

End Function

Private Function Compare(v1 As Variant, v2 As Variant) As Integer
    Dim i As Integer
    If IsNumeric(v1) And IsNumeric(v2) Then v1 = Val(v1): v2 = Val(v2)

    Select Case esmMode
    ' Sort by value (same as esmSortBin for strings)
    Case esmSortVal
        If v1 < v2 Then
            i = -1
        ElseIf v1 = v2 Then
            i = 0
        Else
            i = 1
        End If
    ' Sort case-insensitive
    Case esmSortText
        i = StrComp(v1, v2, 1)
    ' Sort case-sensitive
    Case esmSortbin
        i = StrComp(v1, v2, 0)
    ' Sort by string length
    Case esmSortLen
        If Len(v1) = Len(v2) Then
            If v1 = v2 Then
                i = 0
            ElseIf v1 < v2 Then
                i = -1
            Else
                i = 1
            End If
        ElseIf Len(v1) < Len(v2) Then
            i = -1
        Else
            i = 1
        End If
    End Select
    If fHiToLo Then i = -i
    Compare = i
End Function

Sub Swap(i1 As Integer, i2 As Integer)
    Dim vT As Variant
    vT = lst.list(i1)
    lst.list(i1) = lst.list(i2)
    lst.list(i2) = vT
End Sub

Private Sub Class_Initialize()
    Const sNone = ""
    Const sItemNotFound = "Item not found"
    Const sOutOfRange = "Out of range"
    Const sDuplicateNotAllowed = "Duplicate item not allowed"
    Const sNoSelection = "Nothing selected"
    Const sNotListBox = "Lacks list box methods or properties"
    Const sAlreadySorted = "List box already sorted"
    Const sUnknown = "Unknown error"

    asError(eseNone) = sNone
    asError(eseItemNotFound) = sItemNotFound
    asError(eseOutOfRange) = sOutOfRange
    asError(eseDuplicateNotAllowed) = sDuplicateNotAllowed
    asError(eseNoSelection) = sNoSelection
    asError(eseNotListBox) = sNotListBox
    asError(eseAlreadySorted) = sAlreadySorted
    asError(eseUnknown) = sUnknown
End Sub

Private Sub Class_Terminate()
    Set lst = Nothing
End Sub